{-# OPTIONS_GHC -Wno-ambiguous-fields #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

-- TODO: Move to Brig.User.Account
module Brig.API.User
  ( -- * User Accounts / Profiles
    upgradePersonalToTeam,
    createUser,
    createUserSpar,
    createUserInviteViaScim,
    checkRestrictedUserCreation,
    CheckHandleResp (..),
    checkHandle,
    UserStore.lookupHandle,
    changeAccountStatus,
    changeSingleAccountStatus,
    getLegalHoldStatus,
    Data.lookupName,
    Data.lookupUser,
    Data.lookupRichInfoMultiUsers,
    revokeIdentity,
    deleteUserNoVerify,
    deleteUsersNoVerify,
    deleteSelfUser,
    verifyDeleteUser,
    ensureAccountDeleted,
    deleteAccount,
    checkHandles,
    isBlacklistedHandle,

    -- * Activation
    sendActivationCode,
    preverify,
    activate,
    activateNoVerifyEmailDomain,
    Brig.API.User.lookupActivationCode,

    -- * Password Management
    changePassword,
    lookupPasswordResetCode,

    -- * Blacklisting
    isBlacklisted,
    blacklistDelete,
    blacklistInsert,

    -- * Utilities
    fetchUserIdentity,
  )
where

import Brig.API.Types
import Brig.API.Util
import Brig.App as App
import Brig.Data.Activation (ActivationEvent (..), activationErrorToRegisterError)
import Brig.Data.Activation qualified as Data
import Brig.Data.Client qualified as Data
import Brig.Data.Connection (countConnections)
import Brig.Data.Connection qualified as Data
import Brig.Data.User
import Brig.Data.User qualified as Data
import Brig.Effects.ConnectionStore
import Brig.Effects.UserPendingActivationStore (UserPendingActivation (..), UserPendingActivationStore)
import Brig.Effects.UserPendingActivationStore qualified as UserPendingActivationStore
import Brig.IO.Intra qualified as Intra
import Brig.Options hiding (internalEvents)
import Brig.Team.Email
import Brig.Types.Activation (ActivationPair)
import Brig.Types.Intra
import Brig.User.Auth.Cookie qualified as Auth
import Cassandra hiding (Set)
import Control.Error
import Control.Lens (preview, to, (^.), _Just)
import Control.Monad.Catch
import Data.ByteString.Conversion
import Data.Code
import Data.Coerce (coerce)
import Data.Currency qualified as Currency
import Data.Handle (Handle (fromHandle))
import Data.Id as Id
import Data.Json.Util
import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus)
import Data.List.Extra
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Misc
import Data.Qualified
import Data.Range
import Data.Time.Clock
import Data.UUID.V4 (nextRandom)
import Imports
import Network.Wai.Utilities
import Polysemy
import Polysemy.Error
import Polysemy.Input
import Polysemy.TinyLog (TinyLog)
import Polysemy.TinyLog qualified as Log
import Prometheus qualified as Prom
import System.Logger.Message
import Wire.API.Connection
import Wire.API.Error
import Wire.API.Error.Brig qualified as E
import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team
import Wire.API.Team hiding (newTeam)
import Wire.API.Team.Member (legalHoldStatus)
import Wire.API.Team.Role
import Wire.API.User
import Wire.API.User.Activation
import Wire.API.User.Client
import Wire.API.User.RichInfo
import Wire.API.UserEvent
import Wire.ActivationCodeStore
import Wire.ActivationCodeStore qualified as ActivationCode
import Wire.AuthenticationSubsystem (AuthenticationSubsystem, internalLookupPasswordResetCode)
import Wire.BlockListStore as BlockListStore
import Wire.DeleteQueue
import Wire.EmailSending
import Wire.EmailSubsystem
import Wire.Error
import Wire.Events (Events)
import Wire.Events qualified as Events
import Wire.GalleyAPIAccess as GalleyAPIAccess
import Wire.HashPassword (HashPassword)
import Wire.HashPassword qualified as HashPassword
import Wire.InvitationStore (InvitationStore, StoredInvitation)
import Wire.InvitationStore qualified as InvitationStore
import Wire.NotificationSubsystem
import Wire.PasswordResetCodeStore (PasswordResetCodeStore)
import Wire.PasswordStore (PasswordStore, lookupHashedPassword, upsertHashedPassword)
import Wire.PropertySubsystem as PropertySubsystem
import Wire.RateLimit
import Wire.Sem.Concurrency
import Wire.Sem.Now (Now)
import Wire.Sem.Paging.Cassandra
import Wire.StoredUser
import Wire.TeamSubsystem (TeamSubsystem)
import Wire.TeamSubsystem qualified as TeamSubsystem
import Wire.UserGroupSubsystem
import Wire.UserKeyStore
import Wire.UserStore (UserStore)
import Wire.UserStore qualified as UserStore
import Wire.UserSubsystem as User
import Wire.UserSubsystem.Error (GuardFailure (..), UserSubsystemError (..))
import Wire.UserSubsystem.HandleBlacklist
import Wire.UserSubsystem.UserSubsystemConfig
import Wire.VerificationCode qualified as VerificationCode
import Wire.VerificationCodeGen (mkVerificationCodeGen)
import Wire.VerificationCodeSubsystem

-------------------------------------------------------------------------------
-- Create User

data IdentityError
  = IdentityErrorBlacklistedEmail
  | IdentityErrorUserKeyExists

identityErrorToRegisterError :: IdentityError -> RegisterError
identityErrorToRegisterError = \case
  IdentityErrorBlacklistedEmail -> RegisterErrorBlacklistedEmail
  IdentityErrorUserKeyExists -> RegisterErrorUserKeyExists

identityErrorToBrigError :: IdentityError -> HttpError
identityErrorToBrigError = \case
  IdentityErrorBlacklistedEmail -> StdError $ errorToWai @'E.BlacklistedEmail
  IdentityErrorUserKeyExists -> StdError $ errorToWai @'E.UserKeyExists

verifyUniquenessAndCheckBlacklist ::
  ( Member BlockListStore r,
    Member UserKeyStore r
  ) =>
  EmailKey ->
  ExceptT IdentityError (AppT r) ()
verifyUniquenessAndCheckBlacklist uk = do
  checkKey Nothing uk
  blacklisted <- lift $ liftSem $ BlockListStore.exists uk
  when blacklisted $ throwE IdentityErrorBlacklistedEmail
  where
    checkKey u k = do
      av <- lift $ liftSem $ keyAvailable k u
      unless av $
        throwE IdentityErrorUserKeyExists

createUserSpar ::
  forall r.
  ( Member GalleyAPIAccess r,
    Member TinyLog r,
    Member UserSubsystem r,
    Member Events r,
    Member UserStore r
  ) =>
  NewUserSpar ->
  ExceptT CreateUserSparError (AppT r) CreateUserResult
createUserSpar new = do
  let handle' = newUserSparHandle new
      new' = newUserFromSpar new
      ident = newUserSparSSOId new
      tid = newUserSparTeamId new

  -- Create account
  account <- lift $ newStoredUser new' Nothing (Just tid) handle'
  domain <- viewFederationDomain
  let u = newStoredUserToUser (Qualified account domain)
  lift $ do
    let uid = account.id

    -- FUTUREWORK: make this transactional if possible
    liftSem $ UserStore.createUser account Nothing
    case unRichInfo <$> newUserSparRichInfo new of
      Just richInfo -> wrapClient $ Data.updateRichInfo uid richInfo
      Nothing -> pure () -- Nothing to do
    liftSem $ GalleyAPIAccess.createSelfConv uid
    liftSem $ User.internalUpdateSearchIndex uid
    liftSem $ Events.generateUserEvent uid Nothing (UserCreated u)

  -- Add to team
  userTeam <- withExceptT CreateUserSparRegistrationError $ addUserToTeamSSO u tid (SSOIdentity ident Nothing) (newUserSparRole new)

  -- Set up feature flags
  luid <- lift $ ensureLocal (userQualifiedId u)
  lift $ initAccountFeatureConfig (tUnqualified luid)

  -- Set handle
  lift $ updateHandle' luid handle'

  pure $! CreateUserResult u Nothing (Just userTeam)
  where
    updateHandle' :: Local UserId -> Maybe Handle -> AppT r ()
    updateHandle' _ Nothing = pure ()
    updateHandle' luid (Just h) =
      liftSem $ User.updateHandle luid Nothing UpdateOriginScim (fromHandle h)

    addUserToTeamSSO :: User -> TeamId -> UserIdentity -> Role -> ExceptT RegisterError (AppT r) CreateUserTeam
    addUserToTeamSSO account tid ident role = do
      let uid = userId account
      added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid tid Nothing role
      unless added $
        throwE RegisterErrorTooManyTeamMembers
      lift $ do
        wrapClient $ activateUser uid ident
        void $ onActivated (AccountActivated account)
        liftSem $
          Log.info $
            field "user" (toByteString uid)
              . field "team" (toByteString tid)
              . msg (val "Added via SSO")
      Team.TeamName nm <- lift $ liftSem $ GalleyAPIAccess.getTeamName tid
      pure $ CreateUserTeam tid nm

upgradePersonalToTeam ::
  forall r.
  ( Member GalleyAPIAccess r,
    Member UserStore r,
    Member UserSubsystem r,
    Member TinyLog r,
    Member (Embed HttpClientIO) r,
    Member NotificationSubsystem r,
    Member (Input (Local ())) r,
    Member Now r,
    Member (ConnectionStore InternalPaging) r,
    Member EmailSending r
  ) =>
  Local UserId ->
  BindingNewTeamUser ->
  ExceptT UpgradePersonalToTeamError (AppT r) CreateUserTeam
upgradePersonalToTeam luid bNewTeam = do
  user <- guardUser

  lift $ do
    liftSem $
      for_ (userEmail user) guardUpgradePersonalUserToTeamEmailDomain
    -- generate team ID
    tid <- randomId

    let uid = tUnqualified luid
    createUserTeam <- do
      liftSem $ GalleyAPIAccess.createTeam uid (bnuTeam bNewTeam) tid
      let newTeam = bNewTeam.bnuTeam
      pure $ CreateUserTeam tid (fromRange newTeam.newTeamName)
    liftSem $ GalleyAPIAccess.changeTeamStatus tid Team.Active bNewTeam.bnuCurrency

    liftSem $ UserStore.updateUserTeam uid tid
    liftSem $ User.internalUpdateSearchIndex uid
    liftSem $ Intra.sendUserEvent uid Nothing (teamUpdated uid tid)
    initAccountFeatureConfig uid

    -- send confirmation email
    for_ (userEmail user) $ \email -> do
      sendNewTeamOwnerWelcomeEmail
        email
        tid
        bNewTeam.bnuTeam.newTeamName.fromRange
        (Just user.userLocale)
        user.userDisplayName

    pure $! createUserTeam
  where
    isActive :: SelfProfile -> Bool
    isActive profile = profile.selfUser.userStatus == Active

    guardUser :: ExceptT UpgradePersonalToTeamError (AppT r) User
    guardUser = do
      -- user must be active (not suspended, deleted, ephemeral etc.)
      mSelfProfile <- (find isActive) <$> lift (liftSem $ getSelfProfile luid)
      user <- maybe (throwE UpgradePersonalToTeamErrorUserNotFound) (pure . selfUser) mSelfProfile
      -- check that the user is not part of a team
      when (isJust user.userTeam) $ throwE UpgradePersonalToTeamErrorAlreadyInATeam
      pure user

-- docs/reference/user/registration.md {#RefRegistration}
createUser ::
  forall r p.
  ( Member BlockListStore r,
    Member GalleyAPIAccess r,
    Member (UserPendingActivationStore p) r,
    Member UserKeyStore r,
    Member UserStore r,
    Member UserSubsystem r,
    Member TinyLog r,
    Member Events r,
    Member (Input (Local ())) r,
    Member PasswordResetCodeStore r,
    Member HashPassword r,
    Member InvitationStore r,
    Member ActivationCodeStore r,
    Member RateLimit r
  ) =>
  RateLimitKey ->
  NewUser PlainTextPassword8 ->
  ExceptT RegisterError (AppT r) CreateUserResult
createUser rateLimitKey new = do
  email <- fetchAndValidateEmail new

  -- get invitation and existing account
  (mNewTeamUser, teamInvitation, tid) <-
    case newUserTeam new of
      Just (NewTeamMember i) -> do
        inv <- lift $ liftSem $ internalFindTeamInvitation (mkEmailKey <$> email) i
        pure (Nothing, Just inv, Just inv.teamId)
      Just (NewTeamCreator t) -> do
        for_ (emailIdentity =<< new.newUserIdentity) (lift . liftSem . guardRegisterActivateUserEmailDomain)
        (Just t,Nothing,) <$> (Just . Id <$> liftIO nextRandom)
      Just (NewTeamMemberSSO tid) ->
        pure (Nothing, Nothing, Just tid)
      Nothing -> do
        for_ (emailIdentity =<< new.newUserIdentity) (lift . liftSem . guardRegisterActivateUserEmailDomain)
        pure (Nothing, Nothing, Nothing)
  let mbInv = (.invitationId) <$> teamInvitation
  mbExistingAccount <-
    lift $
      join
        <$> for mbInv do
          \invid -> liftSem $ do
            luid :: Local UserId <- qualifyLocal' (coerce invid)
            User.getLocalAccountBy WithPendingInvitations luid

  let (new', mbHandle) = case mbExistingAccount of
        Nothing ->
          ( new {newUserIdentity = newIdentity email (newUserSSOId new)},
            Nothing
          )
        Just existingAccount ->
          let mbSSOid =
                case (teamInvitation, email, existingAccount.userManagedBy, userSSOId existingAccount) of
                  -- isJust teamInvitation And ManagedByScim implies that the
                  -- user invitation has been generated by SCIM and there is no IdP
                  (Just _, _, ManagedByScim, ssoId@(Just (UserScimExternalId _))) ->
                    -- if the existing user has an external ID, we have to use it because it can differ from the email address
                    ssoId
                  (Just _, Just em, ManagedByScim, _) ->
                    Just $ UserScimExternalId (fromEmail em)
                  _ -> newUserSSOId new
           in ( new
                  { newUserManagedBy = Just existingAccount.userManagedBy,
                    newUserIdentity = newIdentity email mbSSOid
                  },
                existingAccount.userHandle
              )

  -- Create account
  account <-
    lift $ do
      mHashedPassword <-
        traverse
          ( liftSem . HashPassword.hashPassword8 rateLimitKey
          )
          new'.newUserPassword
      newStoredUser new' {newUserPassword = mHashedPassword} mbInv tid mbHandle
  domain <- viewFederationDomain
  let u = newStoredUserToUser (Qualified account domain)
  let uid = account.id
  lift . liftSem $ do
    Log.debug $ field "user" (toByteString uid) . field "action" (val "User.createUser")
    Log.info $ field "user" (toByteString uid) . msg (val "Creating user")
    UserStore.createUser account Nothing
    GalleyAPIAccess.createSelfConv uid
    Events.generateUserEvent uid Nothing (UserCreated u)

  createUserTeam <- do
    activatedTeam <- lift $ do
      case (tid, mNewTeamUser) of
        (Just tid', Just newTeamUser) -> do
          liftSem $ GalleyAPIAccess.createTeam uid (bnuTeam newTeamUser) tid'
          let activating = isJust (newUserEmailCode new)
              newTeam = newTeamUser.bnuTeam
          pure $
            if activating
              then Just $ CreateUserTeam tid' (fromRange newTeam.newTeamName)
              else Nothing
        _ -> pure Nothing

    joinedTeamInvite <- case teamInvitation of
      Just inv -> do
        acceptInvitationToTeam u inv (mkEmailKey inv.email) (EmailIdentity inv.email)
        Team.TeamName nm <- lift $ liftSem $ GalleyAPIAccess.getTeamName inv.teamId
        pure (Just $ CreateUserTeam inv.teamId nm)
      Nothing -> pure Nothing

    joinedTeamSSO <- case (newUserIdentity new', tid) of
      (Just ident@(SSOIdentity (UserSSOId _) _), Just tid') -> Just <$> addUserToTeamSSO u tid' ident
      _ -> pure Nothing

    pure (activatedTeam <|> joinedTeamInvite <|> joinedTeamSSO)

  edata <-
    if isJust teamInvitation
      then pure Nothing
      else handleEmailActivation email uid mNewTeamUser

  lift $ initAccountFeatureConfig uid

  pure $! CreateUserResult u edata createUserTeam
  where
    -- NOTE: all functions in the where block don't use any arguments of createUser

    fetchAndValidateEmail :: NewUser password -> ExceptT RegisterError (AppT r) (Maybe EmailAddress)
    fetchAndValidateEmail newUser = do
      let email = newUserEmail newUser
      for_ (mkEmailKey <$> email) $ \k ->
        verifyUniquenessAndCheckBlacklist k !>> identityErrorToRegisterError
      pure email

    acceptInvitationToTeam ::
      User ->
      StoredInvitation ->
      EmailKey ->
      UserIdentity ->
      ExceptT RegisterError (AppT r) ()
    acceptInvitationToTeam account inv uk ident = do
      let uid = userId account
      ok <- lift $ liftSem $ claimKey uk uid
      unless ok $
        throwE RegisterErrorUserKeyExists
      let minvmeta :: Maybe (UserId, UTCTimeMillis)
          minvmeta = (,inv.createdAt) <$> inv.createdBy
          role :: Role
          role = fromMaybe defaultRole inv.role
      added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid inv.teamId minvmeta role
      unless added $
        throwE RegisterErrorTooManyTeamMembers
      lift $ do
        -- ('insertAccount' sets column activated to False; here it is set to True.)
        wrapClient $ activateUser uid ident
        void $ onActivated (AccountActivated account)
        liftSem do
          Log.info $
            field "user" (toByteString uid)
              . field "team" (toByteString $ inv.teamId)
              . msg (val "Accepting invitation")
          UserPendingActivationStore.remove uid
          InvitationStore.deleteInvitation inv.teamId inv.invitationId

    addUserToTeamSSO :: User -> TeamId -> UserIdentity -> ExceptT RegisterError (AppT r) CreateUserTeam
    addUserToTeamSSO account tid ident = do
      let uid = userId account
      added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid tid Nothing defaultRole
      unless added $
        throwE RegisterErrorTooManyTeamMembers
      lift $ do
        wrapClient $ activateUser uid ident
        void $ onActivated (AccountActivated account)
        liftSem $
          Log.info $
            field "user" (toByteString uid)
              . field "team" (toByteString tid)
              . msg (val "Added via SSO")
      Team.TeamName nm <- lift $ liftSem $ GalleyAPIAccess.getTeamName tid
      pure $ CreateUserTeam tid nm

    -- Handle e-mail activation (deprecated, see #RefRegistrationNoPreverification in /docs/reference/user/registration.md)
    handleEmailActivation ::
      Maybe EmailAddress ->
      UserId ->
      Maybe BindingNewTeamUser ->
      ExceptT RegisterError (AppT r) (Maybe Activation)
    handleEmailActivation email uid newTeam = do
      fmap join . for (mkEmailKey <$> email) $ \ek -> case newUserEmailCode new of
        Nothing -> do
          timeout <- asks (.settings.activationTimeout)
          lift . liftSem $ do
            edata <- newActivationCode ek timeout (Just uid)
            Log.info $
              field "user" (toByteString uid)
                . field "activation.key" (toByteString $ activationKey edata)
                . msg (val "Created email activation key/code pair")
            pure $ Just edata
        Just c -> do
          ak <- liftIO $ Data.mkActivationKey ek
          void $
            activateWithCurrency True (ActivateKey ak) c (Just uid) (bnuCurrency =<< newTeam)
              !>> activationErrorToRegisterError
          pure Nothing

initAccountFeatureConfig :: UserId -> (AppT r) ()
initAccountFeatureConfig uid = do
  mStatus <- preview (App.settingsLens . featureFlagsLens . _Just . to conferenceCalling . to forNew . _Just)
  wrapClient $ traverse_ (Data.updateFeatureConferenceCalling uid . Just) mStatus

-- | 'createUser' is becoming hard to maintain, and instead of adding more case distinctions
-- all over the place there, we add a new function that handles just the one new flow where
-- users are invited to the team via scim.
createUserInviteViaScim ::
  ( Member BlockListStore r,
    Member UserKeyStore r,
    Member UserStore r,
    Member (UserPendingActivationStore p) r,
    Member TinyLog r
  ) =>
  NewUserScimInvitation ->
  ExceptT HttpError (AppT r) User
createUserInviteViaScim (NewUserScimInvitation tid uid extId loc name email _) = do
  let emKey = mkEmailKey email
  verifyUniquenessAndCheckBlacklist emKey !>> identityErrorToBrigError
  account <- lift . wrapClient $ newStoredUserViaScim uid extId tid loc name email
  lift . liftSem . Log.debug $ field "user" (toByteString account.id) . field "action" (val "User.createUserInviteViaScim")

  -- add the expiry table entry first!  (if brig creates an account, and then crashes before
  -- creating the expiry table entry, gc will miss user data.)
  expiresAt <- do
    ttl <- asks (.settings.teamInvitationTimeout)
    now <- liftIO =<< asks (.currentTime)
    pure $ addUTCTime (realToFrac ttl) now
  lift . liftSem $ UserPendingActivationStore.add (UserPendingActivation uid expiresAt)

  lift . liftSem $ UserStore.createUser account Nothing
  newStoredUserToUser . Qualified account <$> viewFederationDomain

-- | docs/reference/user/registration.md {#RefRestrictRegistration}.
checkRestrictedUserCreation :: NewUser password -> ExceptT RegisterError (AppT r) ()
checkRestrictedUserCreation new = do
  restrict <- fromMaybe False <$> asks (.settings.restrictUserCreation)
  when
    ( restrict
        && not (isNewUserTeamMember new)
        && not (isNewUserEphemeral new)
    )
    $ throwE RegisterErrorUserCreationRestricted

  ephemeralUserCreationEnabled <- asks (.settings.ephemeralUserCreationEnabled)
  when (not ephemeralUserCreationEnabled && isNewUserEphemeral new) $
    throwE RegisterErrorEphemeralUserCreationDisabled

-------------------------------------------------------------------------------
-- Forcefully revoke a verified identity

-- | Now that a user can only have an email-based identity, revoking an identity
-- boils down to deactivating the user.
revokeIdentity ::
  ( Member UserSubsystem r,
    Member UserKeyStore r
  ) =>
  EmailAddress ->
  AppT r ()
revokeIdentity key = do
  mu <- liftSem . lookupKey . mkEmailKey $ key
  for_ mu $ \u -> do
    deactivate <- maybe False (not . isSSOIdentity) <$> fetchUserIdentity u
    when deactivate . wrapClient . Data.deactivateUser $ u

-------------------------------------------------------------------------------
-- Change Account Status

changeAccountStatus ::
  forall r.
  ( Member (Embed HttpClientIO) r,
    Member (Concurrency 'Unsafe) r,
    Member UserSubsystem r,
    Member Events r,
    Member AuthenticationSubsystem r
  ) =>
  NonEmpty UserId ->
  AccountStatus ->
  ExceptT AccountStatusError (AppT r) ()
changeAccountStatus usrs status = do
  ev <- mkUserEvent usrs status
  lift $ liftSem $ unsafePooledMapConcurrentlyN_ 16 (update ev) usrs
  where
    update ::
      (UserId -> UserEvent) ->
      UserId ->
      Sem r ()
    update ev u = do
      embed $ Data.updateStatus u status
      User.internalUpdateSearchIndex u
      Events.generateUserEvent u Nothing (ev u)

changeSingleAccountStatus ::
  ( Member UserSubsystem r,
    Member Events r,
    Member (Concurrency Unsafe) r,
    Member AuthenticationSubsystem r
  ) =>
  UserId ->
  AccountStatus ->
  ExceptT AccountStatusError (AppT r) ()
changeSingleAccountStatus uid status = do
  unlessM (wrapClientE $ Data.userExists uid) $ throwE AccountNotFound
  ev <- mkUserEvent (NonEmpty.singleton uid) status
  lift $ do
    wrapClient $ Data.updateStatus uid status
    liftSem $ User.internalUpdateSearchIndex uid
    liftSem $ Events.generateUserEvent uid Nothing (ev uid)

mkUserEvent ::
  ( Traversable t,
    Member (Concurrency Unsafe) r,
    Member AuthenticationSubsystem r
  ) =>
  t UserId ->
  AccountStatus ->
  ExceptT AccountStatusError (AppT r) (UserId -> UserEvent)
mkUserEvent usrs status =
  case status of
    Active -> pure UserResumed
    Suspended -> do
      lift $ liftSem (unsafePooledMapConcurrentlyN_ 16 Auth.revokeAllCookies usrs)
      pure UserSuspended
    Deleted -> throwE InvalidAccountStatus
    Ephemeral -> throwE InvalidAccountStatus
    PendingInvitation -> throwE InvalidAccountStatus

-------------------------------------------------------------------------------
-- Activation

activate ::
  ( Member GalleyAPIAccess r,
    Member TinyLog r,
    Member Events r,
    Member PasswordResetCodeStore r,
    Member UserSubsystem r
  ) =>
  ActivationTarget ->
  ActivationCode ->
  -- | The user for whom to activate the key.
  Maybe UserId ->
  ExceptT ActivationError (AppT r) ActivationResult
activate tgt code usr = activateWithCurrency True tgt code usr Nothing

activateNoVerifyEmailDomain ::
  ( Member GalleyAPIAccess r,
    Member TinyLog r,
    Member Events r,
    Member PasswordResetCodeStore r,
    Member UserSubsystem r
  ) =>
  ActivationTarget ->
  ActivationCode ->
  -- | The user for whom to activate the key.
  Maybe UserId ->
  ExceptT ActivationError (AppT r) ActivationResult
activateNoVerifyEmailDomain tgt code usr = activateWithCurrency False tgt code usr Nothing

activateWithCurrency ::
  ( Member GalleyAPIAccess r,
    Member TinyLog r,
    Member Events r,
    Member PasswordResetCodeStore r,
    Member UserSubsystem r
  ) =>
  Bool ->
  ActivationTarget ->
  ActivationCode ->
  -- | The user for whom to activate the key.
  Maybe UserId ->
  -- | Potential currency update.
  Maybe Currency.Alpha ->
  ExceptT ActivationError (AppT r) ActivationResult
activateWithCurrency verifyEmailDomain tgt code usr cur = do
  key <- wrapClientE $ mkActivationKey tgt
  lift . liftSem . Log.info $
    field "activation.key" (toByteString key)
      . field "activation.code" (toByteString code)
      . msg (val "Activating")
  when verifyEmailDomain $ do
    (emailKey, _) <- wrapClientE (Data.verifyCode key code)
    lift $ liftSem $ guardRegisterActivateUserEmailDomain (emailKeyOrig emailKey)
  event <- Data.activateKey key code usr
  case event of
    Nothing -> pure ActivationPass
    Just e -> do
      (uid, ident, first) <- lift $ onActivated e
      when first $
        lift $
          activateTeam uid
      pure $ ActivationSuccess ident first
  where
    activateTeam uid = do
      tid <- liftSem $ GalleyAPIAccess.getTeamId uid
      for_ tid $ \t -> liftSem $ GalleyAPIAccess.changeTeamStatus t Team.Active cur

preverify ::
  ( MonadClient m,
    MonadReader Env m
  ) =>
  ActivationTarget ->
  ActivationCode ->
  ExceptT ActivationError m (EmailKey, Maybe UserId)
preverify tgt code = do
  key <- mkActivationKey tgt
  Data.verifyCode key code

onActivated ::
  ( Member TinyLog r,
    Member UserSubsystem r,
    Member Events r
  ) =>
  ActivationEvent ->
  AppT r (UserId, Maybe UserIdentity, Bool)
onActivated (AccountActivated account) = liftSem $ do
  let uid = userId account
  Log.debug $ field "user" (toByteString uid) . field "action" (val "User.onActivated")
  Log.info $ field "user" (toByteString uid) . msg (val "User activated")
  User.internalUpdateSearchIndex uid
  Events.generateUserEvent uid Nothing $ UserActivated account
  pure (uid, userIdentity account, True)
onActivated (EmailActivated uid email) = do
  liftSem $ User.internalUpdateSearchIndex uid
  liftSem $ Events.generateUserEvent uid Nothing (emailUpdated uid email)
  wrapHttpClient $ Data.deleteEmailUnvalidated uid
  pure (uid, Just (EmailIdentity email), False)

-- docs/reference/user/activation.md {#RefActivationRequest}
sendActivationCode ::
  forall r.
  ( Member BlockListStore r,
    Member EmailSubsystem r,
    Member GalleyAPIAccess r,
    Member ActivationCodeStore r,
    Member UserKeyStore r,
    Member (Polysemy.Error.Error UserSubsystemError) r,
    Member (Input UserSubsystemConfig) r
  ) =>
  EmailAddress ->
  Maybe Locale ->
  ExceptT SendActivationCodeError (AppT r) ()
sendActivationCode email loc = do
  lift . liftSem $ guardBlockedDomainEmail

  let ek = mkEmailKey email
  doesExist <- lift $ liftSem $ isJust <$> lookupKey ek
  when doesExist $
    throwE $
      UserKeyInUse ek
  blacklisted <- lift . liftSem $ BlockListStore.exists ek
  when blacklisted $
    throwE (ActivationBlacklistedUserKey ek)
  uc <- lift . liftSem $ ActivationCode.lookupActivationCode ek
  case uc of
    Nothing -> sendVerificationEmail ek Nothing -- Fresh code request, no user
    Just (Nothing, c) -> sendVerificationEmail ek (Just c) -- Re-requesting existing code
    Just (Just uid, c) -> sendActivationEmail ek c uid -- User re-requesting activation
  where
    notFound = throwM . UserDisplayNameNotFound
    mkPair ::
      EmailKey ->
      Maybe ActivationCode ->
      Maybe UserId ->
      ExceptT SendActivationCodeError (AppT r) (ActivationKey, ActivationCode)
    mkPair k c u = do
      timeout <- asks (.settings.activationTimeout)
      case c of
        Just c' -> liftIO $ (,c') <$> Data.mkActivationKey k
        Nothing -> lift . liftSem $ do
          dat <- newActivationCode k timeout u
          pure (activationKey dat, activationCode dat)
    sendVerificationEmail ek uc = do
      (key, code) <- mkPair ek uc Nothing
      let em = emailKeyOrig ek
      lift $ liftSem $ sendVerificationMail em key code loc
    sendActivationEmail ek uc uid = do
      -- FUTUREWORK(fisx): we allow for 'PendingInvitations' here, but I'm not sure this
      -- top-level function isn't another piece of a deprecated onboarding flow?
      u <- maybe (notFound uid) pure =<< lift (wrapClient $ Data.lookupUser WithPendingInvitations uid)
      (aKey, aCode) <- mkPair ek (Just uc) (Just uid)
      let ident = userIdentity u
          name = userDisplayName u
          loc' = loc <|> Just (userLocale u)
          em = emailKeyOrig ek
      lift $ do
        -- Get user's team, if any.
        mbTeam <- mapM (fmap Team.tdTeam . liftSem . GalleyAPIAccess.getTeam) (userTeam u)
        -- Depending on whether the user is a team creator, send either
        -- a team activation email or a regular email. Note that we
        -- don't have to check if the team is binding because if the
        -- user has 'userTeam' set, it must be binding.
        case mbTeam of
          Just team
            | team ^. teamCreator == uid ->
                liftSem $ sendTeamActivationMail em name aKey aCode loc' (team ^. teamName)
          _otherwise ->
            liftSem $ (maybe sendActivationMail (const sendEmailAddressUpdateMail) ident) em name aKey aCode loc'

    guardBlockedDomainEmail ::
      ( Member (Input UserSubsystemConfig) r',
        Member (Polysemy.Error.Error UserSubsystemError) r'
      ) =>
      Sem r' ()
    guardBlockedDomainEmail = do
      domain <-
        either (Polysemy.Error.throw . UserSubsystemGuardFailed . InvalidDomain) pure $
          emailDomain email
      blocked <- blockedDomains <$> input
      when (domain `elem` blocked) $
        Polysemy.Error.throw UserSubsystemBlockedDomain

mkActivationKey :: (MonadClient m, MonadReader Env m) => ActivationTarget -> ExceptT ActivationError m ActivationKey
mkActivationKey (ActivateKey k) = pure k
mkActivationKey (ActivateEmail e) =
  liftIO $ Data.mkActivationKey (mkEmailKey e)

-------------------------------------------------------------------------------
-- Password Management

changePassword ::
  ( Member PasswordStore r,
    Member UserStore r,
    Member HashPassword r,
    Member RateLimit r,
    Member AuthenticationSubsystem r
  ) =>
  UserId ->
  PasswordChange ->
  ExceptT ChangePasswordError (AppT r) ()
changePassword uid cp = do
  activated <- lift $ liftSem $ UserStore.isActivated uid
  unless activated $
    throwE ChangePasswordNoIdentity
  currpw <- lift $ liftSem $ lookupHashedPassword uid
  let newpw = cp.newPassword
      rateLimitKey = RateLimitUser uid
  hashedNewPw <- lift . liftSem $ HashPassword.hashPassword8 rateLimitKey newpw
  case (currpw, cp.oldPassword) of
    (Nothing, _) -> lift . liftSem $ upsertHashedPassword uid hashedNewPw
    (Just _, Nothing) -> throwE InvalidCurrentPassword
    (Just pw, Just pw') -> do
      -- We are updating the pwd here anyway, so we don't care about the pwd status
      unlessM (lift . liftSem $ HashPassword.verifyPassword rateLimitKey pw' pw) $
        throwE InvalidCurrentPassword
      whenM (lift . liftSem $ HashPassword.verifyPassword rateLimitKey newpw pw) $
        throwE ChangePasswordMustDiffer
      lift $ liftSem (upsertHashedPassword uid hashedNewPw >> Auth.revokeAllCookies uid)

-------------------------------------------------------------------------------
-- User Deletion

-- | Initiate validation of a user's delete request.  Called via @delete /self@.  Users with an
-- 'UserSSOId' can still do this if they also have an 'Email' and/or password.  Otherwise,
-- the team admin has to delete them via the team console on galley.
--
-- Owners are not allowed to delete themselves.  Instead, they must ask a fellow owner to
-- delete them in the team settings.  This protects teams against orphanhood.
--
-- TODO: communicate deletions of SSO users to SSO service.
--
-- FUTUREWORK(mangoiv): this uses 'UserStore', hence it must be moved to 'UserSubsystem'
-- as an effet operation
deleteSelfUser ::
  forall r.
  ( Member GalleyAPIAccess r,
    Member TinyLog r,
    Member (Embed HttpClientIO) r,
    Member UserKeyStore r,
    Member NotificationSubsystem r,
    Member PasswordStore r,
    Member UserStore r,
    Member EmailSubsystem r,
    Member VerificationCodeSubsystem r,
    Member Events r,
    Member UserSubsystem r,
    Member PropertySubsystem r,
    Member HashPassword r,
    Member RateLimit r,
    Member AuthenticationSubsystem r,
    Member UserGroupSubsystem r
  ) =>
  Local UserId ->
  Maybe PlainTextPassword6 ->
  ExceptT DeleteUserError (AppT r) (Maybe Timeout)
deleteSelfUser luid@(tUnqualified -> uid) pwd = do
  account <- lift . liftSem $ User.getAccountNoFilter luid
  case account of
    Nothing -> throwE DeleteUserInvalid
    Just a -> case userStatus a of
      Deleted -> pure Nothing
      Suspended -> ensureNotOwner a >> go a
      Active -> ensureNotOwner a >> go a
      Ephemeral -> go a
      PendingInvitation -> go a
  where
    ensureNotOwner :: User -> ExceptT DeleteUserError (AppT r) ()
    ensureNotOwner acc = do
      case userTeam acc of
        Nothing -> pure ()
        Just tid -> do
          isOwner <- lift $ liftSem $ GalleyAPIAccess.memberIsTeamOwner tid uid
          when isOwner $ throwE DeleteUserOwnerDeletingSelf
    go a = maybe (byIdentity a) (byPassword a) pwd
    byIdentity a = case emailIdentity =<< userIdentity a of
      Just email -> sendCode a email
      Nothing -> case pwd of
        Just _ -> throwE DeleteUserMissingPassword
        Nothing -> lift . liftSem $ deleteAccount a >> pure Nothing
    byPassword a pw = do
      lift . liftSem . Log.info $
        field "user" (toByteString uid)
          . msg (val "Attempting account deletion with a password")
      actual <- lift $ liftSem $ lookupHashedPassword uid
      case actual of
        Nothing -> throwE DeleteUserInvalidPassword
        Just p -> do
          -- We're deleting a user, no sense in updating their pwd, so we ignore pwd status
          unlessM (lift . liftSem $ HashPassword.verifyPassword (RateLimitUser (tUnqualified luid)) pw p) $
            throwE DeleteUserInvalidPassword
          lift . liftSem $ deleteAccount a >> pure Nothing
    sendCode a target = do
      let gen = mkVerificationCodeGen target
      (lift . liftSem $ createCode gen VerificationCode.AccountDeletion (VerificationCode.Retries 3) (VerificationCode.Timeout 600) (Just (toUUID uid))) >>= \case
        Left (CodeAlreadyExists c) -> throwE $! DeleteUserPendingCode (VerificationCode.codeTTL c)
        Right c -> do
          lift . liftSem . Log.info $
            field "user" (toByteString uid)
              . msg (val "Sending verification code for account deletion")
          let k = VerificationCode.codeKey c
          let v = VerificationCode.codeValue c
          let l = userLocale a
          let n = userDisplayName a
          lift (liftSem $ sendAccountDeletionEmail target n k v l)
            `onException` lift (liftSem $ deleteCode k VerificationCode.AccountDeletion)
          pure $! Just $! VerificationCode.codeTTL c

-- | Conclude validation and scheduling of user's deletion request that was initiated in
-- 'deleteUser'.  Called via @post /delete@.
--
-- FUTUREWORK(mangoiv): this uses 'UserStore', hence it must be moved to 'UserSubsystem'
-- as an effet operation
verifyDeleteUser ::
  ( Member (Embed HttpClientIO) r,
    Member NotificationSubsystem r,
    Member UserKeyStore r,
    Member TinyLog r,
    Member UserStore r,
    Member VerificationCodeSubsystem r,
    Member Events r,
    Member UserSubsystem r,
    Member PropertySubsystem r,
    Member AuthenticationSubsystem r,
    Member UserGroupSubsystem r
  ) =>
  VerifyDeleteUser ->
  ExceptT DeleteUserError (AppT r) ()
verifyDeleteUser d = do
  let key = verifyDeleteUserKey d
  let code = verifyDeleteUserCode d
  c <- lift . liftSem $ verifyCode key VerificationCode.AccountDeletion code
  a <- maybe (throwE DeleteUserInvalidCode) pure (VerificationCode.codeAccount =<< c)
  luid <- qualifyLocal $ Id a
  account <- lift . liftSem $ User.getAccountNoFilter luid
  for_ account $ lift . liftSem . deleteAccount
  lift . liftSem $ deleteCode key VerificationCode.AccountDeletion

-- | Check if `deleteAccount` succeeded and run it again if needed.
-- Called via @delete /i/user/:uid@.
--
-- FUTUREWORK(mangoiv): this uses 'UserStore', hence it must be moved to 'UserSubsystem'
-- as an effet operation
ensureAccountDeleted ::
  ( Member (Embed HttpClientIO) r,
    Member NotificationSubsystem r,
    Member TinyLog r,
    Member UserKeyStore r,
    Member UserStore r,
    Member Events r,
    Member UserSubsystem r,
    Member PropertySubsystem r,
    Member AuthenticationSubsystem r,
    Member UserGroupSubsystem r
  ) =>
  Local UserId ->
  AppT r DeleteUserResult
ensureAccountDeleted luid@(tUnqualified -> uid) = do
  mbAcc <- liftSem $ User.getAccountNoFilter luid
  case mbAcc of
    Nothing -> pure NoUser
    Just acc -> do
      probs <- liftSem $ getPropertyKeys uid

      clients <- wrapClient $ Data.lookupClients uid

      localUid <- qualifyLocal uid
      conCount <- wrapClient $ countConnections localUid [(minBound @Relation) .. maxBound]
      cookies <- wrapClient $ Auth.listCookies uid []

      if notNull probs
        || not (userDeleted acc)
        || notNull clients
        || conCount > 0
        || notNull cookies
        then do
          liftSem $ deleteAccount acc
          pure AccountDeleted
        else pure AccountAlreadyDeleted

-- | Internal deletion without validation.
--
-- Called via @delete /i/user/:uid@ (through `ensureAccountDeleted`), or
-- indirectly via deleting self. Team owners can be deleted if the team is not
-- orphaned, i.e. there is at least one other owner left.
--
-- N.B.: As Cassandra doesn't support transactions, the order of database
-- statements matters! Other functions reason upon some states to imply other
-- states. Please change this order only with care!
--
-- FUTUREWORK(mangoiv): this uses 'UserStore', hence it must be moved to 'UserSubsystem'
-- as an effet operation
-- FUTUREWORK: this does not need the whole User structure, only the User.
deleteAccount ::
  ( Member (Embed HttpClientIO) r,
    Member NotificationSubsystem r,
    Member UserKeyStore r,
    Member TinyLog r,
    Member UserStore r,
    Member PropertySubsystem r,
    Member UserSubsystem r,
    Member Events r,
    Member AuthenticationSubsystem r,
    Member UserGroupSubsystem r
  ) =>
  User ->
  Sem r ()
deleteAccount user = do
  let uid = userId user
  Log.info $ field "user" (toByteString uid) . msg (val "Deleting account")
  do
    -- Free unique keys
    for_ (userEmail user) $ deleteKeyForUser uid . mkEmailKey

    PropertySubsystem.onUserDeleted uid
    UserStore.deleteUser user

  traverse_ (removeUserFromAllGroups uid) user.userTeam

  Intra.rmUser uid (userAssets user)
  embed $ Data.lookupClients uid >>= mapM_ (Data.rmClient uid . (.clientId))
  luid <- embed $ qualifyLocal uid
  User.internalUpdateSearchIndex uid
  Events.generateUserEvent uid Nothing (UserDeleted (tUntagged luid))
  embed do
    -- Note: Connections can only be deleted afterwards, since
    --       they need to be notified.
    Data.deleteConnections uid
  Auth.revokeAllCookies uid

-------------------------------------------------------------------------------
-- Lookups

lookupActivationCode ::
  ( Member ActivationCodeStore r,
    Member (Embed IO) r
  ) =>
  EmailAddress ->
  Sem r (Maybe ActivationPair)
lookupActivationCode email = do
  let uk = mkEmailKey email
  k <- liftIO $ Data.mkActivationKey uk
  c <- fmap snd <$> ActivationCode.lookupActivationCode uk
  pure $ (k,) <$> c

lookupPasswordResetCode ::
  ( Member AuthenticationSubsystem r
  ) =>
  EmailAddress ->
  (AppT r) (Maybe PasswordResetPair)
lookupPasswordResetCode =
  liftSem . internalLookupPasswordResetCode . mkEmailKey

deleteUserNoVerify ::
  (Member DeleteQueue r) =>
  UserId ->
  Sem r ()
deleteUserNoVerify uid = do
  enqueueUserDeletion uid

deleteUsersNoVerify ::
  (Member DeleteQueue r) =>
  [UserId] ->
  AppT r ()
deleteUsersNoVerify uids = do
  liftSem $ for_ uids deleteUserNoVerify
  void $ Prom.addCounter enqueueMultiDeleteCounter (fromIntegral $ length uids)
  Prom.incCounter enqueueMultiDeleteCallsCounter

{-# NOINLINE enqueueMultiDeleteCounter #-}
enqueueMultiDeleteCounter :: Prom.Counter
enqueueMultiDeleteCounter =
  Prom.unsafeRegister $
    Prom.counter
      Prom.Info
        { Prom.metricName = "user_enqueue_multi_delete_total",
          Prom.metricHelp = "Number of users enqueued to be deleted"
        }

{-# NOINLINE enqueueMultiDeleteCallsCounter #-}
enqueueMultiDeleteCallsCounter :: Prom.Counter
enqueueMultiDeleteCallsCounter =
  Prom.unsafeRegister $
    Prom.counter
      Prom.Info
        { Prom.metricName = "user_enqueue_multi_delete_calls_total",
          Prom.metricHelp = "Number of users enqueued to be deleted"
        }

getLegalHoldStatus ::
  ( Member TeamSubsystem r,
    Member UserSubsystem r
  ) =>
  Local UserId ->
  AppT r (Maybe UserLegalHoldStatus)
getLegalHoldStatus uid =
  liftSem $
    traverse getLegalHoldStatus'
      =<< User.getLocalAccountBy NoPendingInvitations uid

getLegalHoldStatus' ::
  (Member TeamSubsystem r) =>
  User ->
  Sem r UserLegalHoldStatus
getLegalHoldStatus' user =
  case userTeam user of
    Nothing -> pure defUserLegalHoldStatus
    Just tid -> do
      teamMember <- TeamSubsystem.internalGetTeamMember (userId user) tid
      pure $ maybe defUserLegalHoldStatus (^. legalHoldStatus) teamMember

isBlacklisted :: (Member BlockListStore r) => EmailAddress -> AppT r Bool
isBlacklisted email = do
  let uk = mkEmailKey email
  liftSem $ BlockListStore.exists uk

blacklistInsert :: (Member BlockListStore r) => EmailAddress -> AppT r ()
blacklistInsert email = do
  let uk = mkEmailKey email
  liftSem $ BlockListStore.insert uk

blacklistDelete :: (Member BlockListStore r) => EmailAddress -> AppT r ()
blacklistDelete email = do
  let uk = mkEmailKey email
  liftSem $ BlockListStore.delete uk
